perm filename WORDS.F4[NEW,LCS]9 blob sn#330367 filedate 1978-01-26 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C  WORDS, TYPE, SETLET, SETNUM , PRESCN
C00021 ENDMK
C⊗;
C  WORDS, TYPE, SETLET, SETNUM , PRESCN
	
	SUBROUTINE WORDS
	INTEGER PWDS
	COMMON R2,JA,RC,J2,R3,R4,R5,R6,R7,X,IA,N
	1,Z,J,KN,ISET,KNT,Q(26),JR /PTR/PWDS(1)
	1 /LIMIT/LIMIT,ITEM,LL,IS,IX
C  /SCX/ IS ALSO IN SCMSS, NOTBMS, RHYTH, BEAMS, NEWR(IN LOOP.FAI), SCAN.FAI
C **** WHEN JALPHA IS EXTENDED FIX LOOP AT 365 AND SUBR. NEWR(IN LOOP)
C **** AND SUBR. SCMSS, NOTBMS, RHYTH AND BEAMS
	COMMON/SCX/JALPHA(30),J4,L,Y,K,RX,RZ,RA,J5
	1/XRN/RN(1) /ALF/INP(72),ML
	COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
	EQUIVALENCE (IBLA,JALPHA(12)),(INP2,INP(2))
	DATA JALPHA/',','-','.','=','(',')','+','*',':',';'
	1 ,'"',' ','$','%','&','@','#','<','>',1H','?','!'
	1 ,"555004020100,"565004020100,"571004020100,"5004020100,
	1 "135004020100,'/','[',']'/
C   FOR ENTERING TEXT: T, POS., STF., NT#., SIZE,  RHYTHM≠0
C NOT ANY LONGER****** R6 ≠0 CALLS NOTE NUM. SETUP
	JR=-1
	KNT=-1
C COUNTER FOR SEPARATE TEXT ITEMS.
CC	IF(R3.NE.999)GO TO 131
	IF(INP2.NE.LF)GO TO 131
C TYPE 'TF n,n,n,n' TO READ TYPEIN FROM A FILE.
	TYPE 331
	ACCEPT 631,KN
	IF(LOOK(KN).EQ.0)RETURN
	R2=R3
	R3=R4
	R4=R5
	R5=R6
C  'TF' PUSHES PARAM LIST ONE NOTCH TO RIGHT.
C  GO BACK IF NO FILE FOUND.  READS ONLY FILES WITH LINE NUMBERS.
	CALL IFILE(21,KN)
	READ(21,431)JR,INP
	JR=0 
CC	R6=1
	GO TO 531
631	FORMAT(A5)
331	FORMAT(' TYPE FILE NAME-- '$)
431	FORMAT(I,72A1)
131	CALL TYPE
531	DO 31 KN=72,1,-1
31	IF(INP(KN).NE.IBLA)GO TO 33
C  KN=NUM OF CHARACTERS
C  DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
C  , - . = ( ) + * : ; " BLANK (FONTS) ' --THIS IS ORDER PAST ALPHAB.
C [=QTR NOTE, ]=HALF NOTE, ↑=#, ↓=b, ↔=NATURAL, 3 SLOTS STILL OPEN

C  50 &=NON-ITALICS(BDR), 51 @=ITALICS(BDI)
C  48 &&=BDL (LIGHT-FACE)     49 IS STILL FREE ****
C  52 #=RETURN TO PRIMITVE FONT, 53 <=OPEN, 54 >=FILLED. ('=55)
C FRENCH ACCENTS=ACCUTE=64, GRAVE=65, CMFLX=66, UMLT=67, CIDLA=68, 69 FREE.
C                 <<          >>       $$        %%       ##
33	L=1
	RC=0
	IF(INP(KN).NE.KSLA)GO TO 333
	IF(INP(KN+1).NE.KSLA)GO TO 133
C  TYPE // TO PRINT A SINGLE SLASH.  (NO SPACE BETWEEN!)
333	KN=KN+1
	INP(KN)=KSLA
C  SO TRAILING BLANKS ARE DELETED.
133	LL=1
	RZ=0 
	ISET=IS
	IF(R3.LT.1000)GO TO 233
	RZ=1
	R3=R3-1000.
	RC=R3
C  ADD 1000 TO POSITION (R3+1000) FOR CENTERING AT POS. R3.
233	RA=R3
C   RA= ADDS UP TOTAL SPACE NEEDED
	RX=0
C  FOR SETLET
368	RN(IS+1)=16
	RN(IS+3)=RA
C  NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
CC	Y=39.6*RSTJ3
C  RBL IS FOR CONTROL(NON-LETTERS, ETC.) CHARACTERS.
	RN(IS+2)=R2
	RN(IS+4)=R4
	CALL NOZERO(R5)
	RN(IS+5)=R5
	IF(R5.GE.100)R5=R5-100
C >100 FOR TEXT IN ORCH SCORES TO GO IN ALL SEP. PARTS.
CKK	KK=0
	DO 364 J5=6,8
	Z=0
	DO 363 J4=1,4
361	IA=INP(L)
	IF(IA.NE.KSLA)GO TO 365
C  NEG. SPACE IS ENTERED IN P1 FOR EACH "FIRST" ITEM.
	IF(INP(L+1).NE.KSLA)GO TO 433
C  TYPE // TO PRINT A SINGLE SLASH.  (NO SPACE BETWEEN!)
CKK	KK=KK+1
	L=L+1
	GO TO 365
433	J3=J4
	DO 367 KA=J5,8
	X=99.
	DO 366 K=J3,4
	Z=Z+X
366	X=X*100.0
	RN(IS+KA)=Z
	J3=1
367	Z=0
	L=L+1
C  L=CHARACTER COUNTER
	GO TO 369
365	DO 362 J=1,30
	IF(IA.NE.JALPHA(J))GO TO 362
	N=35+J
C  FOUND A SPECIAL CHARACTER.
	K=N
	IFNT=0
	IF(N.LT.48)GO TO 39
	IF(N.GT.54)GO TO 39
	IF(IA.NE.INP(L+1))GO TO 39
C NEXT FOR DBL CHARS.
	GO TO(1,2,3,39,7,4,5)N-47
C FOR FRENCH ACCENTS
1	N=66
CIRCUMFLEX   TYPE $$
	GO TO 6
2	N=67
C UMLAUT   TYPE %%
	GO TO 6
3	N=48
C &&=BDL40 FONT
	GO TO 6
4	N=64
C ACCUTE  TYPE >>
	GO TO 6
7	N=68
C CEDILLA  TYPE ##
	GO TO 6
5	N=65
C GRAVE  TYPE <<
CC	IF(N.NE.50)GO TO 39
CC	IF(IA.NE.INP(L+1))GO TO 39
6	K=N
	L=L+1
C  TYPE && FOR LIGHT-FACE (BDL).  PUSH PTR (L) ALONG 1 MORE.
	GO TO 39
362	CONTINUE
38	N=10-(LA-INP(L))/536870912
C   MAGIC NUMBER TO FIND LETTERS
	IF(N.LT.10)N=N+7
	K=N
	IF(KFNT)IFNT=0
	IF(N.LT.40)GO TO 39
	N=N+28
	KFNT=-1
C  TO INITIALIZE AUTOMATIC LOWER CASE SYSTEM.
	K=N-60
C  K IS ACTUAL LETTER NUMB. (a=10, ETC.)
	IFNT=-1
C LOWER CASE LETTERS ARE 60 .GT. UPPER. A=10, a=70, b=71, etc.
39	L=L+1
C  BLANK=47  =99 WHEN NO MORE CHARS TO COME.
	IF(N.LT.63.OR.N.GT.68)CALL SPACER(K,IFNT,RX,3.32)
C  NUM↑↑=19.7/5.96  FOR BASIC SPACE PER LETTER.
C  GET SPACE FOR THIS LETTER.  IGNORE ACCENTS (63-68)
	X=N
	IF(J4.EQ.2)X=X*10000.
	IF(J4.EQ.3)X=X*100.
	IF(J4.EQ.1)X=X*1000000.
363	Z=Z+X
364	RN(IS+J5)=Z
369	RN(IS+9)=RX
	RN(IS+10)=RZ
	IF(RZ.EQ.0)KNT=KNT+1
	IF(RC.NE.0)RN(IS+10)=RC
	RC=0
C  FOR CONTINUATION
	RA=RA+RX*R5
	IF(IA.EQ.KSLA)RA=RA+5
C  SPACES GROUPS DIVIDED BY SLASHES
	RX=0
	IF(RZ.NE.0)GO TO 370
C  SKIP IF P10=1, REQUIRED FOR CONTINUATION OF TEXT.
	IF(IBLANK(IS,7))RZ=-2
C IF LAST CHAR IN P7 IS BLANK RESET WDCNT, GET RID OF P8 AND P9
	IF(IBLANK(IS,6))RZ=-3
C ↑↑↑↑ LAST CHAR IN P6=BLNK ZAPS P7 IF NOT NEEDED. RZ=- CHANGES WORDCNT
370	RN(IS)=7+RZ
	IS=IS+10+RZ
	LL=LL+1
	PWDS(ITEM+LL)=IS
C  PUT IT IN THE PNTR ARRAY
	RZ=1.
	IF(IA.EQ.KSLA)RZ=0
	IF(L.LT.KN)GO TO 368
C   WAS ↑↑↑↑↑↑↑ .LE.    5/22/76

	IF(KNT.GT.0)CALL SETLET
C  GOES TO SETLET AUTOMATICALLY IF MORE THAN ONE SLASH FOUND.
	IF(KFNT)IFNT=0
	KFNT=0
	INP(1)=0
C   SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
	END
C  PACKS 4 CHARS/WD, 3 WDS/ITEM.

	SUBROUTINE TYPE
	COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
	COMMON/ALF/INP(72),ML
	TYPE 8005
	ACCEPT 2114,INP
2114	FORMAT(72A1)
8005	FORMAT(' TYPE --'/)
CC**    	IF(JA.NE.16)CALL LNEND
C  FOR 'SCORE' INPUT
	END

	SUBROUTINE SETLET
	COMMON/SCM/V(76),RR4,NN,Y,LCNT,STAFF,JLIST(200),REND
C  NOTE DIFFERENCE IN V ARRAY LNGTH  76+RR4+NN
	COMMON R2,JA,CENTR,J2,R3,R4,R5,RJQ(17),JQ(14),M,K,J,X,A,B
	1 /PTR/PWDS(1)
CCC	1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(2000)
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),KK /ALF/INP(72),ML
	COMMON/SCN/LEL,LR,LU,LD,KSLA,LE,LC,LS,LF,LA,LI,LW
	1 /POSI/STFP(0/7),J102,POS /LIMIT/LIMIT,ITEM,L,I,IX /XRN/RN(1) 
	1 /RINP/RPOS(2,450) /DPY/ST(4000),MEDIT,IGO
	DIMENSION SU(320)
	EQUIVALENCE (J5,JQ(3)),(ISET,RJQ(9)),(SU(1),ST(3600))
	DATA DISP/0.0/
	KK=L
C  L=NUMBER OF ITEMS TYPED +1
	M=1
	IF(R4.EQ.0)KK=0
C  =0 ALWAYS WANTS PAIRS OF NUMS.
	RR4=R4
C  GIVEN VERTICAL POS.
	R4=20
	RPOS(1,1)=0
	DO 1 K=1,ITEM
	IF(FINDIT(K))GO TO 1
C SKIPS NON-NOTES AND WRONG STAFF
	M=M+1
	RPOS(1,M)=RN(L+3)
1	CONTINUE
	IF(M.EQ.1)RETURN
C  M=1 MEANS NO NOTES ON THIS LINE
	CALL DPYSET(3,SU,320)
	CALL DPYBRT(6)
CC	R6=1
	POS=STFP(J2)
	J5=1
	CALL SORT2(RPOS,M)
	K=2
22	IF(IFIX(RPOS(1,K)*100.).NE.IFIX(RPOS(1,K-1)*100.))GO TO 2
C  ROUNDS OFF POSITION TO 2 DECI. PLACES
	M=M-1
	DO 20 J=K,M
20	RPOS(1,J)=RPOS(1,J+1)
C  DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
	IF(M.LT.K)K=M
	GO TO 22
302	FORMAT(17X'POS. FOR --  ',72A1/)
2	K=K+1
	IF(K.LT.M)GO TO 22
	DO 4 K=2,M
	R3=RHORZ(RPOS(1,K))
	CALL PNUM
	J5=J5+1
4	IF(J5.EQ.10)J5=0
	CALL DPYOUT(3)
	CALL SETPOG(1)
	RPOS(1,M+1)=200
	NN2=1
	J=1
	JJ=1
	IF(B)GO TO 30
C  B IS JR IN 'WORDS'    NEXT FOR READIN FILES WITH WORDS
	READ(21,F78F)X,V
	NN=76
	GO TO 31
C  FLAG FOR ALL BLANKS AT END OF LINE
30	MM=-1
	K=JJ
300	IF(INP(K).NE.' ')MM=0
	IF(INP(K).EQ.KSLA)GO TO 301
	IF(K.EQ.72)GO TO 301
	K=K+1
	GO TO 300
301	IF(MM)GO TO 31
	TYPE 302 ,(INP(LL),LL=JJ,K)
	NN=NN2
	NN2=NN2+1
	ACCEPT F78F,V(NN),V(NN2)
	IF(RR4.EQ.0)NN2=NN2+1
	V(NN2)=0
	JJ=K+1
	IF(K.LT.72)GO TO 30	

31	X=V(J)+1
	DO 32 K=NN,1,-1
32	IF(V(K).NE.0)GO TO 320
320	IF(K.GT.KK)KK=-1
C  NOW PAIRS OF NUMS WILL SET INDIV. VERT. POS.; SINGLE DON'T
3	K=X
	A=RPOS(1,K)
	B=RPOS(1,K+1)
	RN(ISET+3)=A+(B-A)*(X-K)+DISP
C  DISP IS DISPLACEMENT OF CURRENT LETTERS.
	IF(KK.GT.0)GO TO 5
C  NEXT FOR PAIRS OF NUMS.
	RN(ISET+4)=V(J+1)
	J=J+2
	GO TO 6
C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
C TYPE Nn, Vert pos/Nn, Vert pos/  OR  Nn/Nn/ (if P4≠0)
5	J=J+1
6	ISET=ISET+RN(ISET)+3
	IF(RN(ISET).EQ.8)GO TO 6
C  =8 MEANS MORE LETTERS TO COME.
	X=V(J)+1
	IF(X.GT.1)GO TO 3
C CAN'T PUT LETTER AT POS. 0 *********
	K=ITEM+1
	TYPE 321,K
321	FORMAT(' FIRST ITEM WAS ',I3)
	END

	SUBROUTINE PRESCN
C  THIS SORTS OUT NEW INPUT FORMAT - CREATES OLD STYLE.
	COMMON/SCX/JALPHA(30),J4,L,Y,K,RX,RZ,RA,J5
	COMMON/SCN/LL,LR,LU,LD,LSL,LE,LC,LS,LF,LA,LI,LW
	DATA LL/'L'/,LR/'R'/,LU/'U'/,LD/'D'/,LE/'E'/,LSL/'/'/
	1,LC/'C'/,LS/'S'/,LF/'F'/,LA/'A'/,LI/'I'/,LW/'W'/
	COMMON/ALF/INP(72),M/XRN/RN(1) /RINP/IR(900)
	EQUIVALENCE (LCM,JALPHA),(LBL,JALPHA(12))
	1,(LST,JALPHA(8)),(ISEMI,JALPHA(10)),(ICOL,JALPHA(9))
	1,(IDOT,JALPHA(3))
C  CHECK THIS EQUIV.↑↑↑↑
100	IF(ISM)5,55,555
C  -1=PROCESS SOME MORE, 0=1ST TIME, 1=PUT OUT RHYTH
C  !!!!! DON'T STOP IN THE MIDDLE!!!  ISM MUST BE 0 FIRST TIME!!!!
55	JX=0
5	K=0
	J=0
	I=JX
	JX=JX+72
1	K=K+1
	M=INP(K)
15	IF(M.EQ.LBL)GO TO 1
	IF(M.EQ.LCM)GO TO 1
C  REMOVE BLANKS AND COMMAS
	JN=0
	IF(M.LT.'0')GO TO 677
	IF(M.LE.'9')GO TO 2
677	MM=INP(K+1)
3	IF(M.EQ.'P')GO TO 8
	IF(M.EQ.'O')GO TO 8
	IF(M.LT.LA)GO TO 777
	IF(M.GT.'G')GO TO 777
	IF(MM.EQ.LL)GO TO 777
	IF(MM.NE.LA)GO TO 8
C  FINDS NOTES, PROX., AND ORDINARY, -- NOT 'BA' OR 'AL'
777	IF(M.NE.LR)GO TO 9
	IF(MM.EQ.LE)JN=1
C  CATCHES 'R' 'RI' 'REP'
	GO TO 8
9	IF(M.EQ.LSL)GO TO 8
	IF(M.EQ.ISEMI)GO TO 8
	IF(M.EQ.LST)GO TO 8
	IF(M.EQ.ICOL)GO TO 8
	JN=-1
8	J=J+1
	 INP(J)=M
	IF(M.EQ.'X')JN=1
C  PICKS UP 4X ETC. FOR BOTH NOTES AND RHYTH.
	IF(JN.LE.0)GO TO 13
C  PUTS 'REP' INTO RHYTH ALSO
	I=I+1
	IR(I)=M
13	IF(M.EQ.LSL)GO TO 4
	IF(M.EQ.ISEMI)GO TO 4
	IF(M.EQ.LST)GO TO 4
	K=K+1
	M=INP(K)
	GO TO 8

4	IF(JN.NE.0)GO TO 7
	I=I+1
	IR(I)=M
7	IF(M.EQ.LSL)GO TO 1
	IF(M.EQ.ISEMI)GO TO 11
	IF(M.EQ.LST)GO TO 6

2	I=I+1
	IR(I)=M
	K=K+1
	M=INP(K)
	IF(M.EQ.IDOT)GO TO 2
	IF(M.LT.'0')GO TO 15
	IF(M.LE.'9')GO TO 2
C  NO BLANK NEEDED AFTER RHYTH.( /4.AS3/8/ ETC.)
	GO TO 15

11	IF(IR(I).NE.ISEMI)IR(I)=ISEMI
	ISM=-1
	RETURN
C  WE'LL COME BACK FOR MORE.

6	IF(IR(I).NE.LST)IR(I)=LST
	JX=0
	ISM=1
C AFTER THIS WE USE RHYTJ DATA.
	RETURN

555	DO 12 K=1,72
	M=IR(K+JX)
	INP(K)=M
	IF(M.EQ.ISEMI)GO TO 10
C  MORE THAN ONE LINE
12	IF(M.EQ.LST)GO TO 14
10	JX=JX+72
C  MOVE TO THE NEXT 'LINE'
	RETURN
14	ISM=0
	END
	
	FUNCTION IBLANK(IS,N)
	COMMON /XRN/RN(2000)
	IBLANK=0
	IF(AMOD(RN(IS+N),100.0).EQ.99.0)IBLANK=-1
	END